;
; question-pipeline.scm
; 
; An experimental set of question-answering rules
;
; Copyright (c) 2009 Linas Vepstas <linasvepstas@gmail.com>
;
; -----------------------------------------------------------------
; Identify a WH-question and anchor it.
; WH-questions are of the form "Who did X?" and "What is Y?" If a parse
; is identified as a WH-question by this pattern, then the query 
; variable ($qVar, representing what/who/when/where/why) is attached to 
; the "bottom anchor".
;
; Such questions will have a QUERY-TYPE(_$qVar, who) generated by RelEx,
; which is is represented in opencog as:
;
;    InheritanceLink
;        WordInstanceNode "who@15e6eeff"
;        DefinedLinguisticConceptNode "who"
;
; Other WH-questions use "what, when, where, why".
;
(define (wh-question-pattern wh-word)
	(r-varscope
		(r-and
			(r-anchor-node *new-parses-anchor* "$parse")
			(r-decl-word-inst "$qVar" "$parse")

			; Identify the question.
			(r-rlx-flag wh-word "$qVar")
		)
		(r-anchor-node *bottom-anchor* "$qVar")
	)
)

; XXX Support for OrLink in the pattern matcher would simplify this ...
(define wh-question-id-rule-0 (wh-question-pattern "who"))
(define wh-question-id-rule-1 (wh-question-pattern "what"))
(define wh-question-id-rule-2 (wh-question-pattern "when"))
(define wh-question-id-rule-3 (wh-question-pattern "where"))
(define wh-question-id-rule-4 (wh-question-pattern "why"))

; -----------------------------------------------------------------
; Find a possble, candidate seme for this word instance. It is
; a candidate if it has the same lemma form as the word-instance.
(define (r-candidate-of-word-inst word-inst seme)
	(r-and 
		(r-link LemmaLink word-inst "$var-lemma")
		(r-decl-vartype "WordInstanceNode" word-inst)
		(r-decl-vartype "WordNode" "$var-lemma")
		(r-link LemmaLink seme "$var-lemma")
		(r-decl-vartype "SemeNode" seme)
	)
)

; -----------------------------------------------------------------
; The following answers an SVO (subject-verb-object) WH-question.
; This pattern explicitly fails to match questions with prepostions
; in them.
;
(define (wh-svo-question-soln core)
	(r-varscope
		(r-and
			(r-anchor-node *bottom-anchor* "$qVar")
			(r-decl-word-inst "$qVar" "$parse")
			(r-decl-vartype "ParseNode" "$parse")

			; Not needed, since we already have the qvar ... 
			; (r-anchor-node *new-parses-anchor* "$parse")

			(r-decl-word-inst "$verb" "$parse")

			(core "$ans" "$clause")

			; XXX we should also make sure that adverbs, if any, that
			; modify the verb, are also matched up.

			; The below make sure that a previous truth query is not
			; mis-interpreted as a statement.
			(r-not (r-rlx-flag "hyp" "$ans-verb"))
			(r-not (r-rlx-flag "truth-query" "$ans-verb"))

			; These reject self-referential answers for copula
			; questions (who is, what is) XXX need to revisit this.
			; Maybe not needed?
			; (r-not (r-decl-lemma "$ans" "what"))
			; (r-not (r-decl-lemma "$ans" "when"))
			; (r-not (r-decl-lemma "$ans" "where"))
			; (r-not (r-decl-lemma "$ans" "who"))
			; (r-not (r-decl-lemma "$ans" "why"))

			; Reject sentences that have propositions in them.
			(r-decl-vartype "PrepositionalRelationshipNode" "$prep")
			(r-not (r-rlx "$prep" "$clause" "$var-any"))
			(r-not (r-rlx "$prep" "$var-other" "$clause"))
		)
		; (r-link ListLink "$seme-svar" "$ans-verb" "$qVar" "$ans")
		(r-anchor-node *query-soln-anchor* "$ans")
	)
)

; The wh-object provides the core template for questions of the form
; "What did subject verb?" (What did Fred throw?) so that the WH-word 
; is the object of the question.
(define (wh-object answer-obj subj-var)
	(r-and
		(r-rlx "_obj"  "$verb" "$qVar")
		(r-rlx "_subj" "$verb" subj-var)

		; Look for seme matching the subject
		(r-seme-of-word-inst subj-var "$seme-svar")

		; Look for candidate verb semes.
		(r-candidate-of-word-inst "$verb" "$ans-verb")
		(r-rlx "_subj" "$ans-verb" "$seme-svar")
		(r-rlx "_obj"  "$ans-verb" answer-obj)
	)
)

; The wh-subject provides the core template for questions of the form
; "Who verb'ed object?" (Who ate an apple?) so that the WH-word 
; is the subject of the question.
(define (wh-subject answer-subj obj-var)
	(r-and
		(r-rlx "_subj" "$verb" "$qVar")
		(r-rlx "_obj"  "$verb" obj-var)

		; Look for seme matching the object
		(r-seme-of-word-inst obj-var "$seme-ovar")

		; Look for candidate verb semes.
		(r-candidate-of-word-inst "$verb" "$ans-verb")
		(r-rlx "_obj"  "$ans-verb" "$seme-ovar")
		(r-rlx "_subj" "$ans-verb" answer-subj)
	)
)

(define wh-svo-question-rule-0
	(wh-svo-question-soln wh-subject)
)

(define wh-svo-question-rule-1
	(wh-svo-question-soln wh-object)
)

; -----------------------------------------------------------------
; The following answers an SVOP (subject-verb-object-prep) WH-question.
; This pattern explicitly matches questions with prepostions in them.
;
(define wh-svop-question-rule-0
	(r-varscope
		(r-and
			(r-anchor-node *bottom-anchor* "$qVar")
			(r-decl-word-inst "$qVar" "$parse")
			(r-decl-vartype "ParseNode" "$parse")

			(r-decl-word-inst "$verb" "$parse")

			(r-rlx "_subj" "$verb" "$qVar")
			(r-rlx "_obj"  "$verb" "$ovar")
			(r-rlx "$prep" "$ovar" "$pvar")
			(r-decl-vartype "PrepositionalRelationshipNode" "$prep")
			(r-decl-vartype "WordInstanceNode" "$pvar")

			; Look for semes matching the object and prep
			(r-seme-of-word-inst "$ovar" "$seme-ovar")
			(r-seme-of-word-inst "$pvar" "$seme-pvar")

			; Look for candidate verb semes.
			(r-candidate-of-word-inst "$verb" "$ans-verb")
			(r-rlx "_obj"  "$ans-verb" "$seme-ovar")
			(r-rlx "$prep" "$seme-ovar" "$seme-pvar")
			(r-rlx "_subj" "$ans-verb" "$ans")

			; XXX we should also make sure that adverbs, if any, that
			; modify the verb, are also matched up.

			; The below make sure that a previous truth query is not
			; mis-interpreted as a statement.
			(r-not (r-rlx-flag "hyp" "$ans-verb"))
			(r-not (r-rlx-flag "truth-query" "$ans-verb"))

			; Reject answers that pattern-match to triples-questions.
			(r-not (r-decl-lemma "$ans" "who"))
			(r-not (r-decl-lemma "$ans" "what"))
			(r-not (r-decl-lemma "$ans" "when"))
			(r-not (r-decl-lemma "$ans" "where"))
			(r-not (r-decl-lemma "$ans" "why"))
		)
		; (r-link ListLink "$seme-ovar" "$prep" "$pvar" "$seme-pvar" "$ans-verb" "$qVar" "$ans")
		(r-anchor-node *query-soln-anchor* "$ans")
	)
)

; -----------------------------------------------------------------
; The following answers a triple-style WH-question (who, what, when etc.)
; The question is presumed to be a simple triple itself.
;
; To limit the scope of the search (for performance), the bottom
; of the prep-triple is assumed to be anchored.
;
; Basically, we are trying to handle triples of the form
; "capital_of(France, what)" and verifying that "what" is a query,
; and then yanking out the answer.
;
; Note that this uses an unqualified seme promotion: the question
; word and the seme just need to share a common lemma. Thus, this
; will fail when a qualified question is is asked: e.g. "what is
; the fuel of a gasoline engine" as opposed to "a diesel engine".
; 
; # IF %ListLink("# TRIPLE BOTTOM ANCHOR", $qvar) 
;       ^ $tripl($word-inst, $qvar)     ; the question
;       ^ &query_var($qvar)             ; validate WH-question
;       ^ %LemmaLink($word-inst, $word) ; common word-instance
;       ^ %LemmaLink($join-inst, $word) ; common seme
;       ^ $tripl($join-inst, $ans)      ; answer
;       ^ ! &query_var($ans)            ; answer should NOT be a query
;    THEN
;       ^3_&declare_answer($ans)
 
(define (wh-trip-question wh-word wh-clause ans-clause)
	(r-varscope
		(r-and
			(r-anchor-node *bottom-anchor* "$qvar")

			wh-clause  ; the prep-phrase we are matching!
			(r-decl-vartype "PrepositionalRelationshipNode" "$tripl")

			;; XXX someday, this needs to be an or-list of WH- words.
			(r-rlx-flag wh-word "$qvar")
			(r-decl-lemma  "$word-inst" "$word")
			(r-decl-lemma  "$join-inst" "$word")

			ans-clause

			(r-not (r-rlx-flag wh-word "$ans"))
		)
		(r-anchor-node *query-soln-anchor* "$ans")
	)
)

(define wh-trip-question-rule-0
	(wh-trip-question 
		"what"
		(r-rlx "$tripl" "$word-inst" "$qvar")
		(r-rlx "$tripl" "$join-inst" "$ans")
	)
)

(define wh-trip-question-rule-1
	(wh-trip-question 
		"what"
		(r-rlx "$tripl" "$qvar" "$word-inst")
		(r-rlx "$tripl" "$ans"  "$join-inst")
	)
)

(define wh-trip-question-rule-2
	(wh-trip-question 
		"who"
		(r-rlx "$tripl" "$word-inst" "$qvar")
		(r-rlx "$tripl" "$join-inst" "$ans")
	)
)

(define wh-trip-question-rule-3
	(wh-trip-question 
		"who"
		(r-rlx "$tripl" "$qvar" "$word-inst")
		(r-rlx "$tripl" "$ans"  "$join-inst")
	)
)

; -----------------------------------------------------------------
; Identify a truth-query as such, anchor it.
; Basically, we promote the truth-query flag from the head-word
; of the parse, to the parse itself.
;
(define truth-query-id-rule-0
	(r-varscope
		(r-and
			(r-anchor-node *new-parses-anchor* "$sent")
			(r-decl-word-inst "$verb" "$sent")

			; Identify the question.
			(r-rlx-flag "hyp" "$verb")
			(r-rlx-flag "truth-query" "$verb")
		)
		(r-rlx-flag "truth-query" "$sent")
	)
)

; -----------------------------------------------------------------
; 0
; SVO-format truth-query question: "Did John throw a rock?"
;        _subj(throw, John)
;        _obj(throw, rock)
;        HYP (throw, T)
;        TRUTH-QUERY-FLAG (throw, T)
;
; or more generally "did X verb Y?"

(define truth-query-rule-0
	(r-varscope
		(r-and
			(r-anchor-node *new-parses-anchor* "$sent")
			(r-rlx-flag "truth-query" "$sent")
			(r-decl-word-inst "$verb" "$sent")

			; Identify the question.
			(r-rlx "_subj" "$verb" "$svar")
			(r-rlx "_obj"  "$verb" "$ovar")
			(r-rlx-flag "hyp" "$verb")
			(r-rlx-flag "truth-query" "$verb")

			; Look for semes with these same words.
			(r-seme-of-word-inst "$svar" "$ans-svar")
			(r-seme-of-word-inst "$ovar" "$ans-ovar")
			
			; Look for a candidate verb, and verify that the semes
			; decorate the verb the same way.
			(r-candidate-of-word-inst "$verb" "$ans-verb")
			(r-rlx "_subj" "$ans-verb" "$ans-svar")
			(r-rlx "_obj"  "$ans-verb" "$ans-ovar")

			; XXX we should also make sure that adverbs, if any, that
			; modify the verb, are also matched up.

			; The below make sure that a previous truth query is not
			; mis-interpreted as a statement.
			(r-not (r-rlx-flag "hyp" "$ans-verb"))
			(r-not (r-rlx-flag "truth-query" "$ans-verb"))
		)
		(r-anchor-node *query-soln-anchor* "$ans-verb")
	)
)

; -----------------------------------------------------------------
; 1
; Prep-triple-format truth-query question:
; "Is Berlin the capital of Germany?"
;        of(capital, Germany)
;        _obj(be, capital)
;        _subj(be, Berlin)
;        TRUTH-QUERY-FLAG(be, T)
;        HYP(be, T)
; which gets
;
; or more generally "did X verb Y?"

;(define truth-query-rule-1
;	(r-varscope
;		(r-and
;			(r-anchor-node *new-parses-anchor* "$sent")
;			(r-rlx-flag "truth-query" "$sent")
;			(r-decl-word-inst "$verb" "$sent")

; -----------------------------------------------------------------
;
(define *wh-question-id-list* (list
	wh-question-id-rule-0
	wh-question-id-rule-1
	wh-question-id-rule-2
	wh-question-id-rule-3
	wh-question-id-rule-4
))

(define *wh-question-rule-list* (list
	wh-svo-question-rule-0
	wh-svo-question-rule-1
	wh-svop-question-rule-0
))

(define *wh-trip-question-rule-list* (list
	wh-trip-question-rule-0
	wh-trip-question-rule-1
	wh-trip-question-rule-2
	wh-trip-question-rule-3
))

(define *truth-query-id-list* (list
	truth-query-id-rule-0
))

(define *truth-query-rule-list* (list
	truth-query-rule-0
))

; ------------------------ END OF FILE ----------------------------
; -----------------------------------------------------------------

